home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / compile.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  8.9 KB  |  351 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # compile a ui file into tk code - TAKE 2
  8. # Thu Apr  6 14:22:59 PDT 1995
  9.  
  10. # Each project file has the following format:
  11. # 1: title-> WidGet file, created:  <date>
  12.  
  13. # 2: widget_data ...
  14. #
  15. # widget data consists of:
  16. #   Widget  <name>
  17. #   <tab> <type> <name> <value>
  18. #   ...
  19.  
  20. # pick up data filters
  21.  
  22. if {[info procs install_filters] == ""} {
  23.     source filters.tk
  24.     install_filters
  25. }
  26.  
  27. # format string for running "hook" code [not used anymore]
  28.  
  29. set Format {
  30.     if {[info commands %s] != {}} {
  31.         eval {%s $root} $args
  32.     }
  33. }
  34.  
  35. # compile a ui into a tk program
  36. #  file:  the unix file containing the ui description
  37. #  out:      The file to write the tk program to (defaults to stdout)
  38. #  prefix: The procedure prefix
  39. #  run:      Invoke the generated procedure (not used)
  40.  
  41. proc compile {file {out ""} {prefix ""} {run ""}} {
  42.     global Widget_data Format Masters Version
  43.     set Id "WidGet file"
  44.     catch "unset Masters"
  45.     array set map {row height column width}
  46.  
  47.     if {![file readable $file]} {
  48.         puts stderr "$file does not exist"
  49.         return 1
  50.     }
  51.     set fd [open $file r]
  52.  
  53.     set line ""
  54.     gets $fd line
  55.     if {[string first $Id $line] != 0} {
  56.         puts stderr "$file is not a UI file"
  57.         close $fd
  58.         return 1
  59.     }
  60.  
  61.     if {$out == ""} {
  62.         set out_fd stdout
  63.     } else {
  64.         if {[file exists $out] && ![file writable $out]} {
  65.             set _Message "cant write to $out"
  66.             return 1
  67.         }
  68.         set out_fd [open $out w]
  69.     }
  70.     
  71.  
  72.     # gather up all of the data for each widget
  73.  
  74.     while {1} {
  75.         gets $fd line
  76.         if {[eof $fd]} break
  77.  
  78.         # gather entire line
  79.  
  80.         while {![info complete $line]} {
  81.             append line "\n[gets $fd]"
  82.             # puts stderr gulp
  83.             }
  84.         if {[string first Widget $line] == 0} {
  85.             set name [lindex $line 1]
  86.             lappend names $name
  87.             upvar #0 __X_$name data
  88.         } else {
  89.             set index -1
  90.             foreach i {type option value} {
  91.                 set $i [lindex $line [incr index]]
  92.             }
  93.  
  94.             # fix the font name
  95.  
  96.             if {$option == "font"} {
  97.                 # puts stderr "Filtering font"
  98.                 $Widget_data(outfilter:font) dummy font value
  99.             }
  100.  
  101.             if {$option == "master"} {
  102.                 set Masters([string trimleft [expr {$value=="" ? "f" : $value}] .]) 1
  103.             }
  104.             set data($type,$option) $value
  105.         }
  106.     }
  107.     close $fd
  108.  
  109.     # now output the info as a tcl script
  110.  
  111.     if {$prefix == ""} {
  112.         set prefix [file root [file tail $file]]
  113.     }
  114.     puts $out_fd "# interface generated by SpecTcl version $Version from $file"
  115.     puts $out_fd "#   root     is the parent window for this user interface"
  116.     puts $out_fd "\nproc ${prefix}_ui {root args} {"
  117.     puts $out_fd {
  118.     # this treats "." as a special case
  119.  
  120.     if {$root == "."} {
  121.         set base ""
  122.     } else {
  123.         set base $root
  124.     }
  125.     }
  126.  
  127.     # run any prefix code (Turn off for now)
  128.     # puts $out_fd [format $Format ${prefix}_prefix ${prefix}_prefix]
  129.         
  130.     # now create the widgets (and the tags)
  131.     # Sort the widgets to end up with the correct tabbing order
  132.  
  133.     set names [lsort -command "frames_first" $names]
  134.     foreach name $names {
  135.         upvar #0 __X_$name data
  136.  
  137.         if {$name == "f" } continue
  138.  
  139.         # gather up the widget command.
  140.         #  Substitute %W's in -command.  This needs to change
  141.  
  142.         puts -nonewline $out_fd "\t$data(other,type) \$base.$data(other,item_name)"
  143.         set options [lsort [array names data configure,*]]
  144.         set font ""
  145.         foreach option $options {
  146.             regsub configure, $option {} param
  147.             set value $data($option)
  148.             set check [expr [string match *command* $param] || [string match *variable* $param]]
  149.             if {$check && [string match {*%[BWMR]*} $value]} {
  150.                 regsub -all {([][$])} $value {\\\1} value    ;# quote variables and []'s
  151.                 regsub -all {(^|[^%])%W} $value \\1\$base.$data(other,item_name) value
  152.                 regsub -all {(^|[^%])%B} $value \\1\$base value
  153.                 regsub -all {(^|[^%])%R} $value \\1\$root value
  154.                 regsub -all {(^|[^%])%M} $value \\1[real_master $name] value
  155.                 regsub -all {([^\\])?"} $value {\1\\"} value
  156.                 puts -nonewline $out_fd " \\\n\t\t-$param \"$value\""
  157.             } else {
  158.  
  159.                 # To prevent bad fonts from aborting the entire ui,
  160.                 # don't issue -font commands directly, but use "configure"
  161.                 # surrounded by a catch instead
  162.  
  163.                 set stuff "-$param [list $value]"
  164.                 if {$param == "font"} {
  165.                     append font $stuff
  166.                 } else {
  167.                     puts -nonewline $out_fd " \\\n\t\t$stuff"
  168.                 }
  169.             }
  170.         }
  171.  
  172.         # now issue the font configure command in a catch
  173.  
  174.         if {$font != ""} {
  175.             puts -nonewline $out_fd \
  176.                 "\n\tcatch \{\n\t\t\$base.$data(other,item_name) configure \\\n\t\t\t$font\n\t\}"
  177.         }
  178.         puts $out_fd "\n"
  179.     
  180.         # find the tags
  181.         
  182.         if {$data(other,tags) != ""} {
  183.             append tags "\tbindtags \$base.$data(other,item_name) [list $data(other,tags)]\n"
  184.         }
  185.  
  186.     }
  187.  
  188.     # print out any binding tags
  189.  
  190.     if {[info exists tags]} {
  191.         puts $out_fd "\n\t# binding tags\n\n$tags"
  192.     }
  193.  
  194.     # now create the geometry management commands
  195.     # this has to wait until all of the widgets are created to
  196.     # avoid forward references
  197.  
  198.     puts $out_fd "\n\t# Geometry management"
  199.     foreach name $names {
  200.         upvar #0 __X_$name data
  201.         if {[set master [real_master $name]] == ""} {
  202.             continue
  203.         }
  204.         puts $out_fd ""
  205.         puts -nonewline $out_fd "\tblt_table $master \$base.$data(other,item_name) "
  206.         puts -nonewline $out_fd "\t$data(geometry,row),$data(geometry,column) "
  207.         foreach option [lsort [array names data geometry,*]] {
  208.             regsub geometry, $option {} param
  209.             if {$param == "row" || $param == "column"} continue
  210.             puts -nonewline $out_fd " \\\n\t\t-$param [list $data($option)]"
  211.         }
  212.     }
  213.  
  214.     # now for the resize behavior, this is only run for geometry masters"
  215.  
  216.     puts $out_fd "\n\n\t# Resize behavior management"
  217.  
  218.     foreach name [array names Masters] {
  219.         upvar #0 __X_$name data
  220.         # puts "Processing master $name"
  221.         if {$data(other,item_name) == "f"} {
  222.             set master \$root
  223.         } else {
  224.             set master \$base.$data(other,item_name)
  225.         }
  226.         puts $out_fd ""
  227.         # puts "widget:$name master:$master"
  228.         # parray data
  229.         foreach dim {row column} {
  230.             puts $out_fd "\tblt_table $dim $master configure all -resize none"
  231.             set list [get_resize  $data(other,resize_$dim)]
  232.             if {[llength $list] > 0} {
  233.                 puts $out_fd "\tblt_table $dim $master configure [list $list] -resize both"
  234.             }
  235.             set index 0
  236.             foreach size $data(other,min_$dim) {
  237.                 puts $out_fd "\tblt_table $dim $master configure [incr index] -$map($dim) \{$size Inf\}"
  238.             }
  239.         }    
  240.     }
  241.  
  242.     # now output the additional interface code  (turned off for now)
  243.     # puts $out_fd [format $Format ${prefix}_postfix ${prefix}_postfix]
  244.  
  245.     global __X_f
  246.     puts $out_fd "# additional interface code"
  247.     if {[info exists __X_f(other,code)]} {
  248.         puts $out_fd $__X_f(other,code)
  249.     }
  250.     puts $out_fd "# end additional interface code\n"
  251.  
  252.     puts $out_fd "}"
  253.  
  254.     if {$run != ""} {
  255.         puts $out_fd "catch { source [file root [file tail $file]].tcl}"
  256.         if {$run != "."} {
  257.             puts $out_fd "wm withdraw .;toplevel $run;wm title $run [file tail $file]"
  258.         }
  259.         puts $out_fd "[file tail $file]_ui $run        ;# run the interface in ."
  260.     }
  261.  
  262.     if {$out_fd != "stdout"} {
  263.         close $out_fd
  264.         # puts "Closing $out_fd"
  265.     }
  266.     foreach i [info globals __X_*] {
  267.         global $i
  268.         unset $i
  269.     }
  270. }
  271.  
  272. # figure out the resize behavior
  273.  
  274. proc get_resize {list} {
  275.     set index 0
  276.     set result ""
  277.     foreach i $list {
  278.         if {[lindex "x $list" [incr index]] > 1} {
  279.             lappend result $index
  280.         }
  281.     }
  282.     return $result
  283. }
  284.  
  285. # Sort the widgets to generate the proper stacking order
  286. # * Create all the frames first.  Make sure all outer frames are 
  287. #   created before the inner ones
  288. # * Create all widgets in the specified tabbing order.  If the tab order is the
  289. #   same, then use row/col order based on the coordinates of the containing
  290. #   table cell
  291.  
  292. # This version depends upon the running state of SpecTcl, and needs to be
  293. # re-written to permit the compiler to be invoked as a separate app
  294.  
  295. proc frames_first {name1 name2} {
  296.     upvar #0 __X_$name1 data1 __X_$name2 data2
  297.     dputs "compare $name1 $name2"
  298.  
  299.     # both frames
  300.     if {$data1(other,type) == "frame" && $data2(other,type) == "frame"} {
  301.         dputs "  frames: $data2(other,level) - $data1(other,level)"
  302.         return [expr $data1(other,level) - $data2(other,level)]
  303.     }
  304.  
  305.     # 1 frame, 1 widget
  306.     if {$data1(other,type) == "frame"} {
  307.         return -1
  308.     } elseif {$data2(other,type) == "frame"} {
  309.         return 1
  310.     }
  311.  
  312.     # sort by explicit tabbing order field
  313.     if {[set result [string compare $data1(other,tabbing) $data2(other,tabbing)]] != 0} {
  314.         dputs "  order $result"
  315.         return $result
  316.     }
  317.  
  318.     # compute order based on cell coords
  319.  
  320.     set c1 [get_tabbing_coords .can.f.$name1]
  321.     set c2 [get_tabbing_coords .can.f.$name2]
  322.  
  323.     foreach index {0 1} {
  324.         set diff [expr [lindex $c1 $index] - [lindex $c2 $index]]
  325.         dputs "  diff ($index) -> $diff"
  326.         if {$diff != 0} {return $diff}
  327.     }
  328.     dputs "   equal??"
  329.     return 0
  330. }
  331.  
  332.  
  333. # find the real master of this window, as the user may have changed its name.
  334.  
  335. proc real_master {name} {
  336.     upvar #0 __X_$name data
  337.     set master [string trimleft $data(other,master) .]
  338.     dputs $master
  339.  
  340.     if {$name == "f" } return ""
  341.     
  342.     if {$master == ""} {
  343.         return {$root}
  344.     } else {
  345.         # the name of the master may have been changed!
  346.         upvar #0 __X_$master m
  347.         set master $m(other,item_name)
  348.         return \$base.$master
  349.     }
  350. }
  351.